home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / pairs.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-16  |  12.1 KB  |  696 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42. #include <stdio.h>
  43. #include "_scm.h"
  44.  
  45. #ifdef __STDC__
  46. #include <stdarg.h>
  47. #define var_start(x, y) va_start(x, y)
  48. #else
  49. #include <varargs.h>
  50. #define var_start(x, y) va_start(x)
  51. #endif
  52.  
  53.  
  54.  
  55.  
  56. /* {Pairs}
  57.  */
  58.  
  59. PROC (s_cons, "cons", 2, 0, 0, scm_cons);
  60. #ifdef __STDC__
  61. SCM 
  62. scm_cons (SCM x, SCM y)
  63. #else
  64. SCM 
  65. scm_cons (x, y)
  66.      SCM x;
  67.      SCM y;
  68. #endif
  69. {
  70.   register SCM z;
  71.   NEWCELL (z);
  72.   CAR (z) = x;
  73.   CDR (z) = y;
  74.   return z;
  75. }
  76.  
  77. #ifdef __STDC__
  78. SCM 
  79. scm_cons2 (SCM w, SCM x, SCM y)
  80. #else
  81. SCM 
  82. scm_cons2 (w, x, y)
  83.      SCM w;
  84.      SCM x
  85.      SCM y;
  86. #endif
  87. {
  88.   register SCM z;
  89.   NEWCELL (z);
  90.   CAR (z) = x;
  91.   CDR (z) = y;
  92.   x = z;
  93.   NEWCELL (z);
  94.   CAR (z) = w;
  95.   CDR (z) = x;
  96.   return z;
  97. }
  98.  
  99. #ifdef __STDC__
  100. SCM
  101. scm_listify (SCM elt, ...)
  102. #else
  103. SCM
  104. scm_listify (elt, va_alist)
  105.      SCM elt;
  106.      va_dcl
  107.  
  108. #endif
  109. {
  110.   va_list foo;
  111.   SCM answer;
  112.   SCM *pos;
  113.  
  114.   var_start (foo, elt);
  115.   answer = EOL;
  116.   pos = &answer;
  117.   while (elt != SCM_UNDEFINED)
  118.     {
  119.       *pos = scm_cons (elt, EOL);
  120.       pos = &CDR (*pos);
  121.       elt = va_arg (foo, SCM);
  122.     }
  123.   return answer;
  124. }
  125.  
  126. PROC (s_acons, "acons", 3, 0, 0, scm_acons);
  127. #ifdef __STDC__
  128. SCM 
  129. scm_acons (SCM w, SCM x, SCM y)
  130. #else
  131. SCM 
  132. scm_acons (w, x, y)
  133.      SCM w;
  134.      SCM x
  135.      SCM y;
  136. #endif
  137. {
  138.   register SCM z;
  139.   NEWCELL (z);
  140.   CAR (z) = w;
  141.   CDR (z) = x;
  142.   x = z;
  143.   NEWCELL (z);
  144.   CAR (z) = x;
  145.   CDR (z) = y;
  146.   return z;
  147. }
  148.  
  149.  
  150.  
  151.  
  152. PROC (s_pair_p, "pair?", 1, 0, 0, scm_pair_p);
  153. #ifdef __STDC__
  154. SCM
  155. scm_pair_p(SCM x)
  156. #else
  157. SCM
  158. scm_pair_p(x)
  159.      SCM x;
  160. #endif
  161. {
  162.     if IMP(x) return BOOL_F;
  163.     return CONSP(x) ? BOOL_T : BOOL_F;
  164. }
  165.  
  166. PROC (s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x);
  167. #ifdef __STDC__
  168. SCM
  169. scm_set_car_x(SCM pair, SCM value)
  170. #else
  171. SCM
  172. scm_set_car_x(pair, value)
  173.      SCM pair;
  174.      SCM value;
  175. #endif
  176. {
  177.     ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_set_car_x);
  178.     CAR(pair) = value;
  179.     return UNSPECIFIED;
  180. }
  181.  
  182. PROC (s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x);
  183. #ifdef __STDC__
  184. SCM
  185. scm_set_cdr_x(SCM pair, SCM value)
  186. #else
  187. SCM
  188. scm_set_cdr_x(pair, value)
  189.      SCM pair
  190.      SCM value;
  191. #endif
  192. {
  193.     ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_set_cdr_x);
  194.     CDR(pair) = value;
  195.     return UNSPECIFIED;
  196. }
  197.  
  198.  
  199. PROC (s_null_p, "null?", 1, 0, 0, scm_null_p);
  200. #ifdef __STDC__
  201. SCM
  202. scm_null_p(SCM x)
  203. #else
  204. SCM
  205. scm_null_p(x)
  206.      SCM x;
  207. #endif
  208. {
  209.     return NULLP(x) ? BOOL_T : BOOL_F;
  210. }
  211.  
  212. #ifdef __STDC__
  213. long
  214. scm_ilength(SCM sx)
  215. #else
  216. long
  217. scm_ilength(sx)
  218.      SCM sx;
  219. #endif
  220. {
  221.     register long i = 0;
  222.     register SCM x = sx;
  223.     do {
  224.         if IMP(x) return NULLP(x) ? i : -1;
  225.         if NCONSP(x) return -1;
  226.         x = CDR(x);
  227.         i++;
  228.         if IMP(x) return NULLP(x) ? i : -1;
  229.         if NCONSP(x) return -1;
  230.         x = CDR(x);
  231.         i++;
  232.         sx = CDR(sx);
  233.     }
  234.     while (x != sx);
  235.     return -1;
  236. }
  237.  
  238. PROC (s_list_p, "list?", 1, 0, 0, scm_list_p);
  239. #ifdef __STDC__
  240. SCM
  241. scm_list_p(SCM x)
  242. #else
  243. SCM
  244. scm_list_p(x)
  245.      SCM x;
  246. #endif
  247. {
  248.     if (scm_ilength(x)<0) return BOOL_F;
  249.     else return BOOL_T;
  250. }
  251.  
  252. PROC (s_list, "list", 0, 0, 1, scm_list);
  253. #ifdef __STDC__
  254. SCM
  255. scm_list(SCM objs)
  256. #else
  257. SCM
  258. scm_list(objs)
  259.      SCM objs;
  260. #endif
  261. {
  262.   return objs;
  263. }
  264.  
  265. PROC (s_list_length, "list-length", 1, 0, 0, scm_list_length);
  266. #ifdef __STDC__
  267. SCM
  268. scm_list_length(SCM x)
  269. #else
  270. SCM
  271. scm_list_length(x)
  272.      SCM x;
  273. #endif
  274. {
  275.   int i;
  276.   i = scm_ilength(x);
  277.   ASSERT(i >= 0, x, ARG1, s_list_length);
  278.   return MAKINUM (i);
  279. }
  280.  
  281.  
  282. #ifdef __STDC__
  283. int
  284. scm_obj_length (SCM obj)
  285. #else
  286. int
  287. scm_obj_length (obj)
  288.      SCM obj;
  289. #endif
  290. {
  291.   int i;
  292.   i = scm_ilength(obj);
  293.   if (i >= 0)
  294.     return i;
  295.   else if (NIMP (obj))
  296.     {
  297.       if (ROSTRINGP (obj))
  298.     return LENGTH (obj);
  299.       else if (VECTORP (obj))
  300.     return LENGTH (obj);
  301.       else
  302.     return -1;
  303.     }
  304.   else
  305.     return -1;
  306. }
  307.  
  308.  
  309. PROC (s_length, "length", 1, 0, 0, scm_length);
  310. #ifdef __STDC__
  311. SCM
  312. scm_length(SCM x)
  313. #else
  314. SCM
  315. scm_length(x)
  316.      SCM x;
  317. #endif
  318. {
  319.   int i;
  320.   i = scm_obj_length(x);
  321.   if (i >= 0)
  322.     return MAKINUM (i);
  323.   else
  324.     {
  325.       ASSERT(0, x, ARG1, s_length);
  326.       return BOOL_F;
  327.     }
  328. }
  329.  
  330.  
  331. PROC (s_append, "append", 0, 0, 1, scm_append);
  332. #ifdef __STDC__
  333. SCM
  334. scm_append(SCM args)
  335. #else
  336. SCM
  337. scm_append(args)
  338.      SCM args;
  339. #endif
  340. {
  341.     SCM res = EOL;
  342.     SCM *lloc = &res, arg;
  343.     if IMP(args) {
  344.         ASSERT(NULLP(args), args, ARGn, s_append);
  345.         return res;
  346.         }
  347.     ASSERT(CONSP(args), args, ARGn, s_append);
  348.     while (1) {
  349.         arg = CAR(args);
  350.         args = CDR(args);
  351.         if IMP(args) {
  352.             *lloc = arg;
  353.             ASSERT(NULLP(args), args, ARGn, s_append);
  354.             return res;
  355.         }
  356.         ASSERT(CONSP(args), args, ARGn, s_append);
  357.         for(;NIMP(arg);arg = CDR(arg)) {
  358.             ASSERT(CONSP(arg), arg, ARGn, s_append);
  359.             *lloc = scm_cons(CAR(arg), EOL);
  360.             lloc = &CDR(*lloc);
  361.         }
  362.         ASSERT(NULLP(arg), arg, ARGn, s_append);
  363.     }
  364. }
  365.  
  366. PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse);
  367. #ifdef __STDC__
  368. SCM
  369. scm_reverse(SCM lst)
  370. #else
  371. SCM
  372. scm_reverse(lst)
  373.      SCM lst;
  374. #endif
  375. {
  376.     SCM res = EOL;
  377.     SCM p = lst;
  378.     for(;NIMP(p);p = CDR(p)) {
  379.         ASSERT(CONSP(p), lst, ARG1, s_reverse);
  380.         res = scm_cons(CAR(p), res);
  381.     }
  382.     ASSERT(NULLP(p), lst, ARG1, s_reverse);
  383.     return res;
  384. }
  385.  
  386.  
  387. PROC (s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
  388. #ifdef __STDC__
  389. SCM
  390. scm_list_ref(SCM lst, SCM k)
  391. #else
  392. SCM
  393. scm_list_ref(lst, k)
  394.      SCM lst;
  395.      SCM k;
  396. #endif
  397. {
  398.     register long i;
  399.     ASSERT(INUMP(k), k, ARG2, s_list_ref);
  400.     i = INUM(k);
  401.     ASSERT(i >= 0, k, ARG2, s_list_ref);
  402.     while (i-- > 0) {
  403.         ASRTGO(NIMP(lst) && CONSP(lst), erout);
  404.         lst = CDR(lst);
  405.     }
  406. erout:    ASSERT(NIMP(lst) && CONSP(lst),
  407.            NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref);
  408.     return CAR(lst);
  409. }
  410.  
  411. PROC (s_memq, "memq", 2, 0, 0, scm_memq);
  412. #ifdef __STDC__
  413. SCM
  414. scm_memq(SCM x, SCM lst)
  415. #else
  416. SCM
  417. scm_memq(x, lst)
  418.      SCM x;
  419.      SCM lst;
  420. #endif
  421. {
  422.     for(;NIMP(lst);lst = CDR(lst)) {
  423.         ASSERT(CONSP(lst), lst, ARG2, s_memq);
  424.         if (CAR(lst)==x) return lst;
  425.     }
  426.     ASSERT(NULLP(lst), lst, ARG2, s_memq);
  427.     return BOOL_F;
  428. }
  429.  
  430. PROC (s_member, "member", 2, 0, 0, scm_member);
  431. #ifdef __STDC__
  432. SCM
  433. scm_member(SCM x, SCM lst)
  434. #else
  435. SCM
  436. scm_member(x, lst)
  437.      SCM x;
  438.      SCM lst;
  439. #endif
  440. {
  441.     for(;NIMP(lst);lst = CDR(lst)) {
  442.         ASSERT(CONSP(lst), lst, ARG2, s_member);
  443.         if NFALSEP(scm_equal_p(CAR(lst), x)) return lst;
  444.     }
  445.     ASSERT(NULLP(lst), lst, ARG2, s_member);
  446.     return BOOL_F;
  447. }
  448.  
  449. PROC (s_assq, "assq", 2, 0, 0, scm_assq);
  450. #ifdef __STDC__
  451. SCM
  452. scm_assq(SCM x, SCM alist)
  453. #else
  454. SCM
  455. scm_assq(x, alist)
  456.      SCM x;
  457.      SCM alist;
  458. #endif
  459. {
  460.     SCM tmp;
  461.     for(;NIMP(alist);alist = CDR(alist)) {
  462.         ASSERT(CONSP(alist), alist, ARG2, s_assq);
  463.         tmp = CAR(alist);
  464.         ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
  465.         if (CAR(tmp)==x) return tmp;
  466.     }
  467.     ASSERT(NULLP(alist), alist, ARG2, s_assq);
  468.     return BOOL_F;
  469. }
  470.  
  471.  
  472. PROC (s_assoc, "assoc", 2, 0, 0, scm_assoc);
  473. #ifdef __STDC__
  474. SCM
  475. scm_assoc(SCM x, SCM alist)
  476. #else
  477. SCM
  478. scm_assoc(x, alist)
  479.      SCM x;
  480.      SCM alist;
  481. #endif
  482. {
  483.     SCM tmp;
  484.     for(;NIMP(alist);alist = CDR(alist)) {
  485.         ASSERT(CONSP(alist), alist, ARG2, s_assoc);
  486.         tmp = CAR(alist);
  487.         ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
  488.         if NFALSEP(scm_equal_p(CAR(tmp), x)) return tmp;
  489.     }
  490.     ASSERT(NULLP(alist), alist, ARG2, s_assoc);
  491.     return BOOL_F;
  492. }
  493.  
  494.  
  495. PROC (s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
  496. #ifdef __STDC__
  497. SCM
  498. scm_delq_x (SCM item, SCM lst)
  499. #else
  500. SCM
  501. scm_delq_x (item, lst)
  502.      SCM item;
  503.      SCM lst;
  504. #endif
  505. {
  506.   SCM start;
  507.   if (lst == EOL)
  508.     return EOL;
  509.  
  510.   start = lst;
  511.   ASSERT (CONSP (lst), lst, ARG2, s_delq_x);
  512.   if (CAR (lst) == item)
  513.     return CDR (lst);
  514.  
  515.   while (CDR(lst) != EOL)
  516.     {
  517.       ASSERT (CONSP (CDR(lst)), lst, ARG2, s_delq_x);
  518.       if (CAR (CDR (lst)) == item)
  519.     {
  520.       SETCDR (lst, CDR (CDR (lst)));
  521.       return start;
  522.     }
  523.       lst = CDR (lst);
  524.     }
  525.   return start;
  526. }
  527.  
  528.  
  529. PROC (s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
  530. #ifdef __STDC__
  531. SCM
  532. scm_last_pair(SCM sx)
  533. #else
  534. SCM
  535. scm_last_pair(sx)
  536.      SCM sx;
  537. #endif
  538. {
  539.   register SCM res = sx;
  540.   register SCM x;
  541.   ASSERT(NIMP(res) && CONSP(res), res, ARG1, s_last_pair);
  542.   while (!0) {
  543.     x = CDR(res);
  544.     if (IMP(x) || NCONSP(x)) return res;
  545.     res = x;
  546.     x = CDR(res);
  547.     if (IMP(x) || NCONSP(x)) return res;
  548.     res = x;
  549.     sx = CDR(sx);
  550.     ASSERT(x != sx, sx, ARG1, s_last_pair);
  551.   }
  552. }
  553.  
  554. PROC (s_append_x, "append!", 0, 0, 1, scm_append_x);
  555. #ifdef __STDC__
  556. SCM
  557. scm_append_x(SCM args)
  558. #else
  559. SCM
  560. scm_append_x(args)
  561.      SCM args;
  562. #endif
  563. {
  564.   SCM arg;
  565.  tail:
  566.   if NULLP(args) return EOL;
  567.   arg = CAR(args);
  568.   ASSERT(NULLP(arg) || (NIMP(arg) && CONSP(arg)), arg, ARG1, s_append_x);
  569.   args = CDR(args);
  570.   if NULLP(args) return arg;
  571.   if NULLP(arg) goto tail;
  572.   CDR(scm_last_pair(arg)) = scm_append_x(args);
  573.   return arg;
  574. }
  575.  
  576.  
  577. /* m.borza  12.2.91 */
  578. PROC (s_memv, "memv", 2, 0, 0, scm_memv);
  579. #ifdef __STDC__
  580. SCM
  581. scm_memv (SCM x, SCM lst)
  582. #else
  583. SCM
  584. scm_memv (x, lst)
  585.      SCM x;
  586.      SCM lst;
  587. #endif
  588. {
  589.   for(;NIMP(lst);lst = CDR(lst)) {
  590.     ASRTGO(CONSP(lst), badlst);
  591.     if NFALSEP(scm_eqv_p(CAR(lst), x)) return lst;
  592.   }
  593. # ifndef RECKLESS
  594.   if (!(NULLP(lst)))
  595.     badlst: scm_wta(lst, (char *)ARG2, s_memv);
  596. # endif
  597.   return BOOL_F;
  598. }
  599.  
  600.  
  601. /* m.borza  12.2.91 */
  602. PROC (s_assv, "assv", 2, 0, 0, scm_assv);
  603. #ifdef __STDC__
  604. SCM
  605. scm_assv(SCM x, SCM alist)
  606. #else
  607. SCM
  608. scm_assv(x, alist)
  609.      SCM x;
  610.      SCM alist;
  611. #endif
  612. {
  613.   SCM tmp;
  614.   for(;NIMP(alist);alist = CDR(alist)) {
  615.     ASRTGO(CONSP(alist), badlst);
  616.     tmp = CAR(alist);
  617.     ASRTGO(NIMP(tmp) && CONSP(tmp), badlst);
  618.     if NFALSEP(scm_eqv_p(CAR(tmp), x)) return tmp;
  619.   }
  620. # ifndef RECKLESS
  621.   if (!(NULLP(alist)))
  622.     badlst: scm_wta(alist, (char *)ARG2, s_assv);
  623. # endif
  624.   return BOOL_F;
  625. }
  626.  
  627.  
  628. PROC (s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
  629. #ifdef __STDC__
  630. SCM
  631. scm_list_tail(SCM lst, SCM k)
  632. #else
  633. SCM
  634. scm_list_tail(lst, k)
  635.      SCM lst;
  636.      SCM k;
  637. #endif
  638. {
  639.   register long i;
  640.   ASSERT(INUMP(k), k, ARG2, s_list_tail);
  641.   i = INUM(k);
  642.   while (i-- > 0) {
  643.     ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
  644.     lst = CDR(lst);
  645.   }
  646.   return lst;
  647. }
  648.  
  649. static scm_iproc cxrs[] = 
  650. {
  651.   {"car", 0},
  652.   {"cdr", 0},
  653.   {"caar", 0},
  654.   {"cadr", 0},
  655.   {"cdar", 0},
  656.   {"cddr", 0},
  657.   {"caaar", 0},
  658.   {"caadr", 0},
  659.   {"cadar", 0},
  660.   {"caddr", 0},
  661.   {"cdaar", 0},
  662.   {"cdadr", 0},
  663.   {"cddar", 0},
  664.   {"cdddr", 0},
  665.   {"caaaar", 0},
  666.   {"caaadr", 0},
  667.   {"caadar", 0},
  668.   {"caaddr", 0},
  669.   {"cadaar", 0},
  670.   {"cadadr", 0},
  671.   {"caddar", 0},
  672.   {"cadddr", 0},
  673.   {"cdaaar", 0},
  674.   {"cdaadr", 0},
  675.   {"cdadar", 0},
  676.   {"cdaddr", 0},
  677.   {"cddaar", 0},
  678.   {"cddadr", 0},
  679.   {"cdddar", 0},
  680.   {"cddddr", 0},
  681.   {0, 0}
  682. };
  683.  
  684. #ifdef __STDC__
  685. void
  686. scm_init_pairs (void)
  687. #else
  688. void
  689. scm_init_pairs ()
  690. #endif
  691. {
  692.   scm_init_iprocs(cxrs, tc7_cxr);
  693. #include "pairs.x"
  694. }
  695.  
  696.